﻿<%
'
'	七色虎建站系统
'	图像处理(远程图片和本地图片生成缩略图)
'
'	七色虎实验室开放内容
'	缓存第三章：图像缓存
'	2012.8.19

'TODO 测试是否支持图片组件
'TODO 暂时不支持多帧图片

dim Jpeg,dWidth,imgUrl,imgRequest,imgCacheDir,imgLeft

dWidth = 220
imgCacheDir = "cache/img/"

Set Jpeg = Server.CreateObject("Persits.Jpeg")

imgRequest = LCase(Trim(Request.QueryString("img")))
if imgRequest="" then imgRequest = ".noimg"

imgLeft = left(imgRequest, instr(imgRequest, "://")+2)

if imgLeft = "http://" or imgLeft = "https://" or imgLeft = "ftp://" then
	imgUrl = getRemoteFile(imgRequest)
else
	imgUrl = getLocalFile(imgRequest)
end if

if checkFile(imgUrl) then
	Jpeg.Open imgUrl
	' Jpeg.Grayscale 1'变灰
	Jpeg.SendBinary
else
	Jpeg.New 112, 30, &HFFFFFF
	Jpeg.Canvas.Font.Color = &H000000
	Jpeg.Canvas.Font.Family = "Courier New"
	' Jpeg.Canvas.Font.Bold = True '是否加粗
	Jpeg.Canvas.Print 5, 5, "No Found"
	Jpeg.Canvas.Pen.Color = &H000000
	Jpeg.Canvas.Pen.Width = 1
	Jpeg.Canvas.Brush.Solid = False
	Jpeg.Canvas.Bar 1, 1, Jpeg.Width, Jpeg.Height
	Jpeg.SendBinary
end if

function getLocalFile(localUrl)
	Dim transUrl,width
	localUrl = localUrl &""
	transUrl = Server.MapPath(imgCacheDir&Replace(Replace(localUrl, "/", "_xg_"),".","_dh_"))&".jpg"
	localUrl = Server.MapPath(localUrl)
	getLocalFile = transUrl
	if checkFileExist(transUrl) then exit function
	if not checkFileExist(localUrl) then exit function
	Jpeg.Open localUrl'如果不是图片，则跳过
	width = Jpeg.OriginalWidth
	'是否生成缩略图
	if width>dWidth then
		Jpeg.Width = dWidth
		Jpeg.Height = Jpeg.OriginalHeight * dWidth / width
		Jpeg.Save transUrl
	else
		getLocalFile = localUrl
	end if
end function

'获取远程图片，如果不是图片，会自动跳过
function getRemoteFile(remoteUrl)
	Dim xmlHttp,transUrl,width
	on error resume next
	remoteUrl = remoteUrl &""
	transUrl = Server.MapPath(imgCacheDir&Replace(Replace(Replace(Replace(remoteUrl, "://", ""), "/", "_xg_"), "?", "_wh_"),".","_dh_"))&".jpg"
	getRemoteFile = transUrl
	if checkFileExist(transUrl) then exit function
	Server.ScriptTimeout = 20'给20秒获取远程图片
	Set xmlHttp = Server.CreateObject("Microsoft.XMLHTTP")
	with xmlHttp
		.Open "get", remoteUrl, False
	' 	.SetRequestHeader "Content-Length",Len(PostData)
	' 	.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
	' 	.SetRequestHeader "USER-AGENT","NokiaE70-1/3.0 SymbianOS/9.1 Series60/3.0"
	' 	.SetRequestHeader "ACCEPT","*/*"
	' 	.Send PostData
		.Send()
	end with
	If Err.Number <> 0 Then
		Set xmlHttp=Nothing
		Exit Function
	End If
	Jpeg.OpenBinary(xmlHttp.responseBody)'如果不是图片，则跳过
	width = Jpeg.OriginalWidth
	if width>dWidth then
		Jpeg.Width = dWidth
		Jpeg.Height = Jpeg.OriginalHeight * dWidth / width
	end if
	Jpeg.Save transUrl
	Set xmlHttp = Nothing
end function

'判断文件是否是图片
function checkFile(filename)
	on error resume next
	checkFile = false
	dim fstream,fileExt
	fileExt=mid(filename,InStrRev(filename,".")+1)
	if Instr( "|jpg|jpeg|gif|png|bmp|", "|"&fileExt&"|") = 0 then exit function
	if not checkFileExist(filename) then exit function
	checkFile = true
	' 暂时注释以下内容，以提高程序加载速度
	' set fstream=Server.createobject("ADODB.Stream")
	' with fstream
		' .Open
		' .Type=1'adTypeBinary
		' .LoadFromFile filename
		' .position=0
	' end with
	' checkFile = checkImageFromSteam(fstream, fileExt)
	' fstream.Close
	' set fstream=nothing
	' if err.number<>0 then checkFile=false
end function

'从文件流判断文件是否是图片
function checkImageFromSteam(fileStream, typeName)
	dim stamp,i,rt:rt = false
	dim jpg(1):jpg(0)=CByte(&HFF):jpg(1)=CByte(&HD8)
	dim bmp(1):bmp(0)=CByte(&H42):bmp(1)=CByte(&H4D)
	dim png(3):png(0)=CByte(&H89):png(1)=CByte(&H50):png(2)=CByte(&H4E):png(3)=CByte(&H47)
	dim gif(5):gif(0)=CByte(&H47):gif(1)=CByte(&H49):gif(2)=CByte(&H46):gif(3)=CByte(&H39):gif(4)=CByte(&H38):gif(5)=CByte(&H61)
	if not IsNull(fileStream.read) then
		fileStream.position=0
		select case typeName
			case "jpg","jpeg"
				stamp=fileStream.read(2)
				for i=0 to 1
					if ascB(MidB(stamp,i+1,1))=jpg(i) then rt=true else rt=false
				next
			case "gif"
				stamp=fileStream.read(6)
				for i=0 to 5
					if ascB(MidB(stamp,i+1,1))=gif(i) then rt=true else rt=false
				next
			case "png"
				stamp=fileStream.read(4)
				for i=0 to 3
					if ascB(MidB(stamp,i+1,1))=png(i) then rt=true else rt=false
				next
			case "bmp"
				stamp=fileStream.read(2)
				for i=0 to 1
					if ascB(MidB(stamp,i+1,1))=bmp(i) then rt=true else rt=false
				next
		end select
	end if
	checkImageFromSteam = rt
end function

'判断文件是否存在，兼容不支持Fso的空间
function checkFileExist(filename)
	dim fso,fStream
	checkFileExist = false
	on error resume next
	set fso = Server.CreateObject("Scripting.FileSystemObject")
	If Err.Number <> 0 Then
		'空间不支持fso
		set fStream = Server.CreateObject("ADODB.Stream")
		with fStream
			.Type = 1
			.Mode = 3
			.Open
			.LoadFromFile filename
		end with
		If Err.Number <> 0 Then
			checkFileExist = false
		Else
			checkFileExist = True
		End If
		set fStream=nothing
	Else
		checkFileExist= fso.FileExists(filename)
		set fso=Nothing
	End If
end function
%>